

'--------------------------------------------------
' Hands-On 29-1
' See the code in the Courses1.xml file.
'--------------------------------------------------


'--------------------------------------------------
' Hands-On 29-2
' Please follow the instructions in the book.
'--------------------------------------------------


'--------------------------------------------------
' Hands-On 29-3
' Please follow the instructions in the book.
'--------------------------------------------------


'--------------------------------------------------
' Hands-On 29-4
' Please follow the instructions in the book.
'--------------------------------------------------


'--------------------------------------------------
' Hands-On 29-5
' See the Northwind_Employees.xml file.
'--------------------------------------------------


'--------------------------------------------------------------
' Coe in "Exporting and Importing Data via an XML Map" section
'--------------------------------------------------------------


Sub ExportToString()
    Dim strEmpData As String
    
    ActiveWorkbook.XmlMaps("dataroot_Map").ExportXml Data:=strEmpData
    Debug.Print strEmpData
End Sub


' Statements to be entered in the Immediate window

ActiveWorkbook.XmlMaps("dataroot_Map").Export "C:\XMLWithExcel07\InternalContacts.xml"
ActiveWorkbook.XmlMaps("dataroot_Map").Import URL: = "C:\XMLWithExcel07\Davolio.xml", Overwrite: = True

Debug.Print ActiveWorkbook.XmlMaps("dataroot_Map").DataBinding
ActiveWorkbook.XmlMaps("dataroot_Map").DataBinding.LoadSettings("C:\XMLWithExcel07\Employees.xml")
ActiveWorkbook.XmlMaps("dataroot_Map").DataBinding.Refresh


'--------------------------------------------------
' Hands-On 29-6
'--------------------------------------------------

Sub AddNew_XMLMap()
    Dim lstCourses As ListObject
    Dim lstCol As ListColumn
    Dim objMap As XmlMap
    Dim mapName As String
    Dim strXPath As String

    On Error GoTo ErrorHandler

    ' Create a new XML map
    ActiveWorkbook.XmlMaps.Add _
      ("C:\XMLWithExcel07\Courses1.xml", "Courses").Name = _
       "Courses_Map"

    Set objMap = ActiveWorkbook.XmlMaps("Courses_Map")
    Range("B20").Select

    ' Create a new List object
    Set lstCourses = ActiveSheet.ListObjects.Add

    ' Bind the first XML element to the first table column
    strXPath = "/Courses/Course/@ID"
    With lstCourses.ListColumns(1)
       .XPath.SetValue objMap, strXPath
       .Name = "ID"
    End With

    ' Add a column to the table
    ' and bind it to an XML node
    Set lstCol = lstCourses.ListColumns.Add
    strXPath = "/Courses/Course/Title"
    With lstCol
      .XPath.SetValue objMap, strXPath
      .Name = "Title"
    End With

    ' Add a column to the table
    ' and bind it to an XML node
    Set lstCol = lstCourses.ListColumns.Add

    strXPath = "/Courses/Course/Startdate"
    With lstCol
      .XPath.SetValue objMap, strXPath
      .Name = "Start Date"
    End With

    ' Add a column to the table
    ' and bind it to an XML node
    Set lstCol = lstCourses.ListColumns.Add

    strXPath = "/Courses/Course/Sessions"
    With lstCol
      .XPath.SetValue objMap, strXPath
      .Name = "Sessions"
    End With

    ' Set some XML Properties
    With ActiveWorkbook.XmlMaps("Courses_Map")
      .ShowImportExportValidationErrors = False
      .AdjustColumnWidth = True
      .PreserveColumnFilter = True
      .PreserveNumberFormatting = True
      .AppendOnImport = False
    End With

    ' Refresh the XML table in the worksheet
    ActiveWorkbook.XmlMaps("Courses_Map").DataBinding.Refresh
Exit Sub

ErrorHandler:
    MsgBox "The following error has occurred: " & vbCrLf _
        & Err.Description
End Sub


'Statement to be entered in the Immediate Window

? ThisWorkbook.XMLMaps(1).Schemas(1).Xml



'--------------------------------------------------
' Hands-On 29-7
' No code in this Hands-On.
' Please follow the instructions in the book.
'--------------------------------------------------


'--------------------------------------------------
' Hands-On 29-8
'--------------------------------------------------

Sub Load_ReadXMLDoc()
    Dim xmlDoc As MSXML2.DOMDocument60

    ' Create an instance of the DOMDocument
    Set xmlDoc = New MSXML2.DOMDocument60

    ' Disable asynchronous loading
    xmlDoc.async = False

    ' Load XML information from a file
    If xmlDoc.Load("C:\XMLWithExcel07\Courses1.xml") Then
        ' Use the DOMDocument object's XML property to
        ' retrieve the raw data
        Debug.Print xmlDoc.XML
        ' Use the DOMDocument object's Text poperty to
        ' retrieve the actual text stored in nodes
        Sheets(2).Range("A1").Value = xmlDoc.Text
    End If
End Sub


'--------------------------------------------------
' Hands-On 29-9
'--------------------------------------------------

Sub LearnAboutNodes()
    Dim xmlDoc As MSXML2.DOMDocument60
    Dim xmlNode As MSXML2.IXMLDOMNode

    ' Create an instance of the DOMDocument
    Set xmlDoc = New MSXML2.DOMDocument60

    xmlDoc.async = False

    ' Load XML information from a file
    xmlDoc.Load ("C:\XMLWithExcel07\Courses1.xml")

    ' find out the number of child nodes in the document
    If xmlDoc.HasChildNodes Then
        Debug.Print "Number of Child Nodes: " & _
                    xmlDoc.ChildNodes.Length

        ' iterate through the child nodes to gather information
        For Each xmlNode In xmlDoc.ChildNodes
            Debug.Print "Node Name: " & xmlNode.nodeName
            Debug.Print vbTab & "Type: " & _
                    xmlNode.nodeTypeString & _
                    "(" & xmlNode.NodeType & ")"
            Debug.Print vbTab & "Text: " & xmlNode.Text
        Next xmlNode
    End If
End Sub


'--------------------------------------------------
' Hands-On 29-10
'--------------------------------------------------

Sub IterateThruElements()
    Dim xmlDoc As MSXML2.DOMDocument60
    Dim xmlNodeList As MSXML2.IXMLDOMNodeList
    Dim xmlNode As MSXML2.IXMLDOMNode
    Dim myNode As MSXML2.IXMLDOMNode

    ' Create an instance of the DOMDocument
    Set xmlDoc = New MSXML2.DOMDocument60
    xmlDoc.async = False

    ' Load XML information from a file
    xmlDoc.Load ("C:\XMLWithExcel07\Courses1.xml")

    ' Find out the number of child nodes in the document
    Set xmlNodeList = xmlDoc.getElementsByTagName("*")

    ' Open a new workbook and paste the data
    Workbooks.Add
    Range("A1:B1").Formula = Array("Element Name", "Text")
    For Each xmlNode In xmlNodeList
      For Each myNode In xmlNode.ChildNodes
        If myNode.NodeType = NODE_TEXT Then
          ActiveCell.Offset(0, 0).Formula = xmlNode.nodeName
          ActiveCell.Offset(0, 1).Formula = xmlNode.Text
        End If
      Next myNode
      ActiveCell.Offset(1, 0).Select
    Next xmlNode
    Columns("A:B").AutoFit
End Sub


'--------------------------------------------------
' Hands-On 29-11
'--------------------------------------------------

Sub SelectNodes_SpecifyCriterion()
    Dim xmlDoc As MSXML2.DOMDocument60
    Dim xmlNodeList As MSXML2.IXMLDOMNodeList
    Dim myNode As Variant

    ' Create an instance of the DOMDocument
    Set xmlDoc = New MSXML2.DOMDocument60
    xmlDoc.async = False

    ' Load XML information from a file
    xmlDoc.Load ("C:\XMLWithExcel07\Courses1.xml")

    ' Retrieve all the nodes that match the specified criterion
    Set xmlNodeList = xmlDoc.SelectNodes("//Title")
    If Not (xmlNodeList Is Nothing) Then
       For Each myNode In xmlNodeList
         Debug.Print myNode.Text
       Next myNode
    End If
End Sub


'--------------------------------------------------
' Hands-On 29-12
'--------------------------------------------------

Sub Select_SingleNode()
    Dim xmlDoc As MSXML2.DOMDocument60
    Dim xmlSingleN As MSXML2.IXMLDOMNode

    ' Create an instance of the DOMDocument
    Set xmlDoc = New MSXML2.DOMDocument60
    xmlDoc.async = False

    ' Load XML information from a file
    xmlDoc.Load ("C:\XMLWithExcel07\Courses1.xml")

    ' Retrieve the reference to a particular node
    Set xmlSingleN = xmlDoc.SelectSingleNode("//Title")
    Debug.Print xmlSingleN.Text
End Sub


'--------------------------------------------------
' Hands-On 29-13
'--------------------------------------------------

Sub Select_SingleNode_2()
    Dim xmlDoc As MSXML2.DOMDocument60
    Dim xmlSingleN As MSXML2.IXMLDOMNode

    ' Create an instance of the DOMDocument
    Set xmlDoc = New MSXML2.DOMDocument60
    xmlDoc.async = False

    ' Load XML information from a file
    xmlDoc.Load ("C:\XMLWithExcel07\Courses1.xml")

    ' Retrieve the reference to a particular node
    Set xmlSingleN = xmlDoc.SelectSingleNode("//Course//@ID")
    If xmlSingleN Is Nothing Then
       Debug.Print "No nodes selected."
    Else
       Debug.Print xmlSingleN.Text
       xmlSingleN.Text = "VBA1EX2007"
       Debug.Print xmlSingleN.Text
       xmlDoc.Save "C:\XMLWithExcel07\Courses1.xml"
    End If
End Sub


'--------------------------------------------------
' Hands-On 29-14
'--------------------------------------------------

Sub SaveRst_ADO()
    Dim rst As ADODB.Recordset
    Dim conn As New ADODB.Connection
    Const strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" _
       & "Data Source=C:\Ex07_HandsOn\Northwind.mdb"

    ' Open a connection to the database
    conn.Open strConn

    ' Execute a select SQL statement against the database
    Set rst = conn.Execute("SELECT * FROM Products")

    ' Delete the file if it exists
    On Error Resume Next
    Kill "C:\XMLWithExcel07\Products.xml"

    ' Save the recordset as an XML file
    rst.Save "C:\XMLWithExcel07\Products.xml", adPersistXML
End Sub



'--------------------------------------------------
' Hands-On 29-15
'--------------------------------------------------

Sub OpenAdoFile()
    Dim rst As ADODB.Recordset
    Dim StartRange As Range
    Dim h As Integer

    ' Create a recordset and fill it with
    ' the data from the XML file
    Set rst = New ADODB.Recordset
    rst.Open "C:\XMLWithExcel07\Products.xml", _
                 "Provider=MSPersist"

    ' Display the number of records
    MsgBox rst.RecordCount

    ' Open a new workbook
    Workbooks.Add

    ' Copy field names as headings to the first row
    ' of the worksheet
    For h = 1 To rst.fields.Count
      ActiveSheet.Cells(1, h).Value = rst.fields(h - 1).Name
    Next

    ' Specify the cell range to receive the data (A2)
    Set StartRange = ActiveSheet.Cells(2, 1)

    ' Copy the records from the recordset
    ' beginning in cell A2
    StartRange.CopyFromRecordset rst

    ' Autofit the columns to make the data fit
    Range("A1").CurrentRegion.Select
    Columns.AutoFit

    ' Close the workbook and save the file
    ActiveWorkbook.Close SaveChanges:=True, _
       Filename:="C:\Ex07_ByExample\Products.xlsx"
End Sub


'--------------------------------------------------
' Hands-On 29-16
'--------------------------------------------------

Sub SaveToDOM()
    Dim conn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim xmlDoc As MSXML2.DOMDocument60
    Dim myNode As IXMLDOMNode
    Dim strCurValue As String

    ' Declare constant used as database connection string
    Const strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" _
      & "Data Source=C:\Ex07_ByExample\Northwind.mdb"

    ' Open a connection to the database
    Set conn = New ADODB.Connection
    conn.Open strConn

    ' Open the Shippers table
    Set rst = New ADODB.Recordset
    rst.Open "Shippers", conn, adOpenStatic, _
                             adLockOptimistic

    ' Create a new XML DOMDocument object
    Set xmlDoc = New MSXML2.DOMDocument60

    ' Add the default namespace declaration
    ' to the Namespace names of the DOMDocument object
    ' using the setProperty method of the DOMDocument object
           
    xmlDoc.setProperty "SelectionNamespaces", _
     "xmlns:rs='urn:schemas-microsoft-com:rowset'" & _
     " xmlns:z='#RowsetSchema'"


    ' Save the recordset directly into
    ' the XML DOMDocument object
    rst.Save xmlDoc, adPersistXML
    Debug.Print xmlDoc.XML

    ' Modify shipper's phone
    Set myNode = xmlDoc.SelectSingleNode( _
        "//z:row[@CompanyName='Speedy Express']/@Phone")
    strCurValue = myNode.Text
    Debug.Print strCurValue
    myNode.Text = "(508)" & Right(strCurValue, 9)
    Debug.Print myNode.Text

    xmlDoc.Save "C:\XMLWithExcel07\Shippers_Modified.xml"
       
    ' Cleanup
    Set xmlDoc = Nothing
    Set conn = Nothing
    Set rst = Nothing
    Set myNode = Nothing
End Sub


'--------------------------------------------------
' Hands-On 29-17
'--------------------------------------------------

Public blnIsFileSelected As Boolean 'Module level variable


Sub UnzipExcelFile()
    Dim objShell As Object
    
    Dim ZipFile, ZipFolder, SourceFile, objFile
    Dim strStartDir As String

    strStartDir = "C:\Ex07_ByExample"
    
    'change folder
    If ActiveWorkbook.Path <> strStartDir Then
        ChDir strStartDir
    End If
    
    
    ' get Excel 2007 file to unzip
    SourceFile = Application.GetOpenFilename _
        (FileFilter:="Excel Files (*.xlsx; *.xlsm), *.xlsx; *.xlsm", _
          Title:="Select Excel 2007 file you want to unzip")
    
    'exit if file was not selected
    If SourceFile = False Then
        blnIsFileSelected = False
        Exit Sub
    End If
    
    blnIsFileSelected = True
    ZipFile = SourceFile & ".zip"
    
    'create the zip file
    FileCopy SourceFile, ZipFile
   
    'Create new folder to store unzipped files
    ZipFolder = "C:\Ex07_ByExample\ZipPackage"
    On Error Resume Next
    MkDir ZipFolder
    
    'Copy package files to the ZipPackage folder
    Set objShell = CreateObject("Shell.Application")
    
    For Each objFile In objShell.Namespace(ZipFile).items
        objShell.Namespace(ZipFolder).CopyHere (objFile)
    Next objFile
    
     'Activate windows Explorer
    Shell "Explorer.exe /e," & ZipFolder, vbNormalFocus
    
    'remove the zip file and release resources
    Kill ZipFile
    Set objShell = Nothing
    Set objFile = Nothing
End Sub


'--------------------------------------------------
' Hands-On 29-18
'--------------------------------------------------

Sub CreateEmptyZipFile(strFileName As String)
    Dim strHeader As String
    Dim fso As Object
    
    strHeader = Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    
    ' delete the file if it already exists
    If Len(Dir(strFileName)) > 0 Then
        Kill strFileName
    End If
    
    ' add a required header
    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.CreateTextFile(strFileName).Write strHeader    
End Sub


Sub ZipToExcel()
    Dim objShell As Object
    Dim ZipFile, ZipFolder, SourceFile, objFile
    Dim strStartDir As String
    Dim ExcelFile As String
    Dim mFlag As Boolean

    ZipFolder = "C:\Ex07_ByExample\ZipPackage"
    ZipFile = "C:\Ex07_ByExample\PackageModified.zip"
    mFlag = False
    
    'check if folder is empty
    If Len(Dir(ZipFolder & "\*.*")) < 1 Then
        MsgBox "There are no files to zip."
        Exit Sub
    End If
    
    ' check if a vba project exists
    If Len(Dir(ZipFolder & "\xl\vbaProject.bin")) > 0 Then
        mFlag = True
    End If
    
    'Create an empty zip file
    CreateEmptyZipFile (ZipFile)
    
    'Copy files from ZipFolder to the ZipFile
    On Error Resume Next
    Set objShell = CreateObject("Shell.Application")
  
    For Each objFile In objShell.Namespace(ZipFolder).items
        objShell.Namespace(ZipFile).CopyHere (objFile)
        Application.Wait (Now + TimeValue("0:00:10"))
    Next objFile
    
    'Create Excel file name
    If mFlag Then
        ExcelFile = Replace(ZipFile, ".zip", ".xlsm")
    Else
        ExcelFile = Replace(ZipFile, ".zip", ".xlsx")
    End If
    
    'Rename the ZipFile
    Name ZipFile As ExcelFile
    
    Set objShell = Nothing
    Set objFile = Nothing
    
    MsgBox "Zipping files completed."
End Sub


'--------------------------------------------------
' Hands-On 29-19
'--------------------------------------------------

Sub ListUniqueValues()
    Dim xmlDoc As DOMDocument
    Dim myNodeList As IXMLDOMNodeList
    Dim i As Integer
    Dim iLen As Integer
    
    Set xmlDoc = New DOMDocument
    xmlDoc.async = False
    xmlDoc.Load ("C:\Ex07_ByExample\ZipPackage\xl\sharedStrings.xml")
    Set myNodeList = xmlDoc.SelectNodes("//t")
    iLen = myNodeList.Length
    
    Worksheets(1).Activate
    For i = 0 To iLen - 1
        Range("A" & i + 1).Formula = myNodeList(i).Text
    Next
    Columns("A").AutoFit
    
    Set myNodeList = Nothing
    Set xmlDoc = Nothing
End Sub

'--------------------------------------------------
' Hands-On 29-20
'--------------------------------------------------

Sub Text_Replace()
    Dim xmlDoc As DOMDocument
    Dim myNode As IXMLDOMNode
    Dim srchStr As String
    Dim newStr As String
    Dim strFileToEdit As String
    
    strFileToEdit = "C:\Ex07_ByExample\ZipPackage\xl\sharedStrings.xml"
    
    Call UnzipExcelFile
    If blnIsFileSelected = False Then Exit Sub
    
    Set xmlDoc = New DOMDocument
    xmlDoc.async = False
    xmlDoc.Load (strFileToEdit)
    
    srchStr = InputBox("Please enter the string to find:", "Search for String")
    
    If srchStr <> "" Then
        ' find the text that needs to be replaced
        Set myNode = xmlDoc.SelectSingleNode("//t[text()='" + srchStr + "']")
        If myNode Is Nothing Then Exit Sub
    Else
        Exit Sub
    End If
    
    ' replace text
    newStr = InputBox("Please enter the replacement string for " _
            & srchStr, "Replace with String")
    If newStr <> "" Then
       myNode.Text = newStr
       xmlDoc.Save strFileToEdit
    Else
        Exit Sub
    End If
    
    ' zip the files in the package
    Call ZipToExcel
    
    Set xmlDoc = Nothing
    Set myNode = Nothing
End Sub


'--------------------------------------------------
' Hands-On 29-21
'--------------------------------------------------

Sub RetrieveAllTextValues()
    Dim xmlDoc As DOMDocument
    Dim myNodeList1 As IXMLDOMNodeList
    Dim myNodeList2 As IXMLDOMNodeList
    Dim myNodeList3 As IXMLDOMNodeList
    Dim strArray() As String
    Dim i As Integer
    Dim iLen As Integer
    
    Set xmlDoc = New DOMDocument
    xmlDoc.async = False
    
    xmlDoc.Load ("C:\Ex07_ByExample\ZipPackage\xl\sharedStrings.xml")
    Set myNodeList1 = xmlDoc.SelectNodes("//t")

    iLen = myNodeList1.Length
    ReDim strArray(iLen)
    
    For i = 0 To iLen - 1
        strArray(i) = myNodeList1(i).Text
    Next
    
    xmlDoc.async = False
    xmlDoc.Load ("C:\Ex07_ByExample\ZipPackage\xl\worksheets\sheet1.xml")
    Set myNodeList2 = xmlDoc.SelectNodes("//sheetData/row/c[@t='s']/@r")
    Set myNodeList3 = xmlDoc.SelectNodes("//sheetData/row/c[@t='s']/v")
       
  
    Worksheets(2).Activate
    i = 0

    For i = 0 To myNodeList2.Length - 1
        With Range(myNodeList2(i).Text)
          .Value = strArray(myNodeList3(i).Text)
        End With
    Next
    
    Range("A1").CurrentRegion.Select
    Selection.EntireColumn.AutoFit
    
    Set myNodeList1 = Nothing
    Set myNodeList2 = Nothing
    Set myNodeList3 = Nothing
    Set xmlDoc = Nothing
End Sub

'--------------------------------------------------
' Hands-On 29-22
'--------------------------------------------------

Sub ChangeLeftMargin_RemovePageSetup()
   Dim xmlDoc As DOMDocument
   Dim myNode As IXMLDOMNode
    
   Set xmlDoc = New DOMDocument
   xmlDoc.async = False
   xmlDoc.Load ("C:\Ex07_ByExample\ZipPackage\xl\worksheets\sheet1.xml")
   Set myNode = xmlDoc.SelectSingleNode("/worksheet/pageMargins/@left")
   xmlDoc.Save ("C:\Ex07_ByExample\ZipPackage\xl\worksheets\sheet1.xml")
 
   Debug.Print "previous left margin = " & myNode.Text
   myNode.Text = "0.50"
   Set myNode = xmlDoc.SelectSingleNode("//pageSetup")
   On Error Resume Next
   myNode.ParentNode.RemoveChild myNode
   xmlDoc.Save ("C:\Ex07_ByExample\ZipPackage\xl\worksheets\sheet1.xml")
   Set myNode = Nothing
   Set xmlDoc = Nothing
End Sub


